;;; tls.cfg.el --- Harden emacs's TLS default settings

;; Copyright (C) 2020 Stefano Mazzucco <stefano AT curso DOT re>

;;; Commentary:
;; GNU Emacs has unsafe TLS settings, let's try and fix them see
;; Inspired and informed by
;; https://github.com/antifuchs/safe-tls-defaults-mode
;; https://old.reddit.com/r/emacs/comments/8sykl1/emacs_tls_defaults_are_downright_dangerous/
;; https://news.ycombinator.com/item?id=17573969https://github.com/antifuchs/safe-tls-defaults-mode

;;; Code:

(defvar safer-tls/priority-string
  "NONE:+SECURE192:+SECURE128:-VERS-TLS-ALL:+VERS-TLS1.2:+VERS-TLS1.3:-AES-256-CBC:-AES-128-CBC:-AES-128-GCM:-RSA:%%PROFILE_MEDIUM"
  "TLS priority string as defined by https://gnutls.org/manual/html_node/Priority-Strings.html page.")

(defvar safer-tls/network-security-level 'high)

(defvar safer-tls/diffie-helman-bits 2048)

(defvar safer-tls/use-ocsp nil
  "Enable Online Certificate Status Protocol (OCSP).
This option will issue a request to verify the status of the
certificate.  While it improves security, it reduces privacy
since external servers will be queried.  For this reason it's
disabled by default.")

(defvar safer-tls/use-dane nil
  "Enable DNS-based Authentication of Named Entities (DANE).
This option will, in addition to certificate authentication using
the trusted CAs, verify the server certificates using the DANE
information available via DNSSEC.  It's disabled because not many
servers support it.")

;; require *after* defvar to avoid errors
(require 'subr-x)
(require 'gnutls)
(require 'nsm)
(require 'starttls)                     ; deprecated in Emacs 27
(require 'tls)                          ; deprecated in Emacs 27

(defun safer-tls/--find-ca-cert (candidates)
  "Find the CA Certificate in CANDIDATES (a list of file path strings).  Error if not found."
  (if-let ((ca-cert (car (seq-filter (lambda (f) (and (file-exists-p f) (not (file-directory-p f)))) candidates))))
      ca-cert
    (error "CA Certificate not found!")))

(defun safer-tls/--make-gnutls-cli-argument-list (&optional use-ocsp use-dane)
  "Generate a gnu-tls cli argument list.
If true, USE-OCSP and USE-DANE will enable those options."
  (seq-filter
   #'identity
   `(,(and use-ocsp "--ocsp")
     ,(and use-dane "--dane")
     ,(format "--priority=%s" safer-tls/priority-string)
     ,(format "--dh-bits=%s" safer-tls/diffie-helman-bits)
     ,(format "--x509cafile=%s" (safer-tls/--find-ca-cert gnutls-trustfiles)))))

(defun safer-tls/setup ()
  "Set up safer TLS defaults."
  (custom-set-variables
   '(gnutls-min-prime-bits safer-tls/diffie-helman-bits)
   '(gnutls-verify-error t)
   '(gnutls-algorithm-priority safer-tls/priority-string)
   '(network-security-level safer-tls/network-security-level))

  (when (executable-find "gnutls-cli")
    (advice-add 'gnutls-available-p :override #'(lambda () '())) ;; Disables gnutls (TODO: re-enable in Emacs 27?)
    (let* ((args (safer-tls/--make-gnutls-cli-argument-list safer-tls/use-ocsp safer-tls/use-dane))
           (gnutls-cli (list (concat "gnutls-cli " (string-join args " ") " --port %p %h")))
           (starttls-args (mapcar (lambda (x) (replace-regexp-in-string "%%" "%" x)) args)))
      (setq ; not using custom-set-variables because of weird behavior when themes are initialized.
       tls-checktrust 'ask
       tls-program gnutls-cli
       starttls-success "- Options:" ;; run gnutls-cli to connect to server, issue STARTTLS, negotiate (Ctrl-D), check out last line of output
       starttls-extra-arguments starttls-args ;; replace unescape %%
       starttls-use-gnutls t))))

  ;; Test functions
(defun safer-tls/test-emacs-client ()
  "Run an SSL test for the Emacs client and display the results in a buffer."
  (switch-to-buffer
   (url-retrieve-synchronously "https://clienttest.ssllabs.com/ssltest/viewMyClient.html")))

(defun safer-tls/test-bad-ssl ()
  "Try to load sites from https://badssl.com and return the ones that fail the test (i.e. that are loaded)."
  (seq-filter #'identity
              (mapcar
               (lambda (host) (when (ignore-errors (url-retrieve-synchronously host nil t 5)) host))
               '(
                 "https://expired.badssl.com/"
                 "https://wrong.host.badssl.com/"
                 "https://self-signed.badssl.com/"
                 "https://untrusted-root.badssl.com/"
                 "https://revoked.badssl.com/"
                 "https://pinning-test.badssl.com/"
                 "https://sha1-intermediate.badssl.com/"
                 "https://rc4-md5.badssl.com/"
                 "https://rc4.badssl.com/"
                 "https://3des.badssl.com/"
                 "https://null.badssl.com/"
                 "https://mozilla-old.badssl.com/"
                 "https://dh480.badssl.com/"
                 "https://dh512.badssl.com/"
                 "https://dh1024.badssl.com/"
                 "https://dh-small-subgroup.badssl.com/"
                 "https://dh-composite.badssl.com/"
                 "https://invalid-expected-sct.badssl.com/"
                 "https://no-sct.badssl.com/"
                 "https://subdomain.preloaded-hsts.badssl.com/"
                 "https://superfish.badssl.com/"
                 "https://edellroot.badssl.com/"
                 "https://dsdtestprovider.badssl.com/"
                 "https://preact-cli.badssl.com/"
                 "https://webpack-dev-server.badssl.com/"
                 "https://captive-portal.badssl.com/"
                 "https://mitm-software.badssl.com/"
                 "https://sha1-2017.badssl.com/"
                 ))))

(defun safer-tls/message-test-bad-ssl ()
  "Test sites from https://badssl.com and print results in the Message buffer."
  (if-let* ((failed (safer-tls/test-bad-ssl)))
      (warn (format
             "\n\nThe below sites should not be loaded (check https://badssl.com/ for more info):\n%s\n\n"
             (string-join failed "\n")))
    (message "No BAD SSL sites have been loaded, that is good!")))


(defun safer-tls/--smtp-starttls (process)
  "Send commands to smtp PROCESS for starttls."
  (accept-process-output process 1)
  (process-send-string process "EHLO safer-tls-test-starttls\n")
  (accept-process-output process 1)
  (process-send-string process "STARTTLS\n"))

(defun safer-tls/--imap-starttls (process)
  "Send commands to imap PROCESS for starttls."
  (accept-process-output process 1)
  (process-send-string process "A STARTTLS\n"))

(defun safer-tls/--smtp-exit (process)
  "Send commands to smtp PROCESS to exit."
  (accept-process-output process 1)
  (process-send-string process "QUIT\n"))

(defun safer-tls/--imap-exit (process)
  "Send commands to imap PROCESS to exit."
  (accept-process-output process 1)
  (process-send-string process "A LOGOUT\n"))

(defun safer-tls/test-starttls (host proto port)
  "Test starttls connection to HOST using PROTO on PORT.
Proto can be `imap' or `smtp'."
  (let ((test-buffer (get-buffer-create (format "*%s*" host))))
    (with-current-buffer-window
     test-buffer nil nil
     (let ((stream
            (starttls-open-stream "safer-tls-test-starttls" test-buffer host port)))
       (cond
        ((string-equal proto 'imap) (safer-tls/--imap-starttls stream))
        ((string-equal proto 'smtp) (safer-tls/--smtp-starttls stream))
        (error "INVALID proto %s" proto))
       (accept-process-output stream 1)
       (message "%s" (starttls-negotiate stream))
       (cond
        ((string-equal proto 'imap) (safer-tls/--imap-exit stream))
        ((string-equal proto 'smtp) (safer-tls/--smtp-exit stream))
        (error "INVALID proto %s" proto))
       (message (format "STARTTLS for %s:%s tested successfully" host port))))))

(provide 'tls.cfg)
;;; tls.cfg.el ends here
